perm filename DREDIT.OLD[DRW,LCS] blob sn#396826 filedate 1978-11-17 generic text, type T, neo UTF8
	SUBROUTINE DREDIT
	COMMON/ED/K,NEXT,NN,NX,NY,J
	COMMON /RZ/RSZ,IPLT,RJB,CENTR
	COMMON /RC/MCLEF(400),IST(4000)
	COMMON/ZN/SCLEF(400,2),N
	COMMON/LL/LL
	COMMON/JJJ/JJJ
	EQUIVALENCE(M,SCLEF(1,2)),(KK,SCLEF(1,1))
	NEXTX=NEXT-1
	J=MCLEF(1)
20	IF(K.EQ.'D')GO TO 1
C  MOVE CURSOR TO INSERT POINT, TYPE CR.
9	FORMAT(' SET POINT ',$)
	IF(JJJ.EQ.-2)GO TO 131
C  FOR CONTINUING RELATIVE CHANGE
CC	IF(JJJ.EQ.0)JJK=0
5	TYPE 9
	ACCEPT 3,L

	IF(L.EQ.'B'.OR.L.EQ.'N')RETURN
C N OR B=BACKUP, J=INSERT OR ALTER TO JUMP, C=ALTER JUMP TO CONT.
	IF(L.EQ.' ')GO TO 12
	IF(L.NE.'F')GO TO 50
	MCLEF(NEXT-1)=MCLEF(NEXT-1)+200000000
	RETURN
C ABOVE SET NEW FILL POINT.
50	REREAD 33,ML,MLA
	IF(JJJ)JJJ=-2
C TO SET POINT BY NUM(NOT FOR FILLER)	NOT NOW IN!
131	IF(M.GE.0)CALL UNPACK(NEXTX,NX,NY,MCLEF)
C  FOR RELATIVE POS. CHANGE
	X=NX+ML
	Y=NY+MLA
	GO TO 13
12	CALL RDCUR(NX,NY)
130	X=STPT(FLOAT(NX),RJB)
	Y=STPT(FLOAT(NY),CENTR)
13	NX=GTPT(X,RJB)
	NY=GTPT(Y,CENTR)
	CALL SETCUR(NX,NY,0)
	IF(K.EQ.0)GO TO 14
	NT=NEXT
	L=NT
40	FORMAT(' POINT OK? (Y,N,B,J,F OR C) ',$)
C Y=YES,N=NO,B=BACKUP,J=JUMP,F=START FILL,C=CONTINUE(NULLIFY JUMP)
	TYPE 4,L,X,Y
	TYPE 40
	ACCEPT 3,L
	IF(L.EQ.'B')RETURN
	IF(L.EQ.'N')GO TO 5
	IF(K.NE.'A')GO TO 8
C  WHAT IS ABOVE FOR?????
	NT=NEXTX
	GO TO 7
11	FORMAT(I3,')',2I6,1X$)
CC8	TYPE 19
CC	ACCEPT 3,L
CC	IF(L.EQ.'B')RETURN
8	A=X
	B=Y
	K=0
	GO TO 12
C NOW ASSUMES → IF NO ← POINT FOUND
14	IF(NX.EQ.SCLEF(NT-2,1).AND.NY.EQ.SCLEF(NT-2,2))NT=NT-1
15	X=A
	Y=B
	J=J+1
	DO 6 L=J,NT+1,-1
6	MCLEF(L)=MCLEF(L-1)
7	LL=0
	NX=X
	NY=Y
	IF(MCLEF(NT).GT.100000000.AND.L.NE.'C')LL=(MCLEF(NT)/100000000)*
	1 100000000
	IF(L.EQ.'J')LL=100000000
	IF(L.EQ.'F')LL=200000000
	K=MCLEF(NT)
	CALL REPACK(NT,NX,NY,MCLEF)
	GO TO 100
CC19	FORMAT(' OTHER POINT? ',$)
3	FORMAT(A1)
33	FORMAT(2I)
4	FORMAT(I4,')',2F6.0)
C  NT IS FOR INSERTS
1	IF(J-NEXT)RETURN
	DO 10 L=NEXT,J+1
	IF(L.EQ.'F')LL=200000000
10	MCLEF(L-1)=MCLEF(L)
	J=J-1
100	MCLEF(1)=J
	KK=0
	IF(MCLEF(2).LT.100000000)MCLEF(2)=MCLEF(2)+100000000
	CALL DPYSET(1,IST,4000)
	CALL DPYBRT(5)
	KK=1
	CALL RDRAW(2,MCLEF(1),MCLEF)
	CALL DPYOUT(1)
CC	RETURN
CC2	CALL RDCUR(NX,NY)
	END

C*******************************************************
	FUNCTION STPT(A,X)
	COMMON /RZ/RSZ,IPLT,RJB,CENTR
	R=.5
	Q=A/RSZ-X
	IF(Q)R=-R
	STPT=IFIX(Q+R)
	RETURN
	END

	FUNCTION GTPT(A,X)
	COMMON /RZ/RSZ,IPLT,RJB,CENTR
	GTPT=(A+X)*RSZ
	END



	SUBROUTINE SMOOTH(JQ)
	COMMON/ED/KX,NEXT,NN,NX,NY,J/LL/L
	COMMON /RC/MCLEF(400),IST(4000)
	COMMON /RZ/RSZ,IPLT,RJB,CENTR
	COMMON /FL/IC,NJ,NQ,RZ,IXRX,XGP,RXGP
	DIMENSION BUF2(700),SX(512),SY(512)
	COMMON/NFF/NE(513)
	DATA INC/10/
	RR=RSZ
CC	IF(IPLT.EQ.0)RR=RR*1.7
	COMMON X(100),Y(100),N,X1(512),Y1(512),S(100),K
	IF(IPLT.EQ.0.AND.JQ.EQ.0)CALL DPYSET(1,IST,4000)
	IF(JQ.NE.' ')CALL HYDPOG(1)
	JL=0
	NOFIL=-1
	IF(JQ.EQ.0)NOFIL=0
100	JY=2
	IF(IPLT.EQ.0)CALL DPYSET(3,BUF2,700)
	J=MCLEF(1)
7	JX=J
8	KX=0
	DO 1 K=JY,J
	CALL UNPACK(K,JA,JB,MCLEF)
	IF(L.GE.100000000.AND.K.GT.JY)GO TO 6
C  JUMP WHEN INVIS. VECT.
	KX=KX+1
	X(KX)=JA+RJB
1	Y(KX)=JB+CENTR
9	X(KX+1)=999.
4	N=KX
	CALL SS
	JL=JL+1
	JK=JL
	SX(JL)=X1(1)*RR
	SY(JL)=Y1(1)*RR
	CALL LINES(X1(1),Y1(1),3)
	DO 5 K=2,512,INC
	JL=JL+1
	SX(JL)=X1(K)*RR
	SY(JL)=Y1(K)*RR
	NE(JL)=0
5	CALL LINES(X1(K),Y1(K),2)
	IF(SX(JL).NE.SX(JK))SX(JK)=SX(JL)
	IF(SY(JL).NE.SY(JK))SY(JK)=SY(JL)
	NE(JK)=3
C FOR INVIS. VECTOR
	IF(IPLT.EQ.0)CALL DPYOUT(3)
10	IF(JX.NE.J)GO TO 7
	CALL SETPOG(1)
	IF(NOFIL)RETURN
200	NE(1)=JL
	CALL FILLQ(SX,SY,NE)
	RETURN
6	JY=K
	JX=JY
	GO TO 9
	END

	SUBROUTINE EDTYP(K,X,Y,JJJ)
	TYPE 57
	ACCEPT 1,K,X,Y
	IF(K.NE.' ')JJJ=0
	IF(K.EQ.':'.OR.JJJ)GO TO 2
C  TYPE "A" OR ":" TO ALTER
	IF(K.NE.'G')RETURN
	JJJ=-1
2	K='A'
57	FORMAT(' TYPE D, A, I OR X ',$)
C  M  N1, N2  =  MOVE SEGS N1 THROUGH N2.
1	FORMAT(A1,2F)
	END

	SUBROUTINE ITYP
	COMMON /RZ/RSZ,IPLT,RJB,CENTR
	COMMON/ED/K,NEXT,NN,NX,NY,J
	A=STPT(FLOAT(NX),RJB)
	B=STPT(FLOAT(NY),CENTR)
	TYPE 1,NN,A,B
1	FORMAT(I4,')',2F6.0)
	END

	SUBROUTINE FILLQ(Q,R,N)
	DIMENSION Q(1),R(1),N(1)
	COMMON /RZ/RSZ,IPLT,RJB,CENTR
	M=6
	IF(IPLT)M=1
1	RZ=RSZ
	RSZ=1.0
CC	IF(IPLT.EQ.0)RSZ=1./1.7
	CALL FILLER(Q,R,N,M)
	RSZ=RZ
	IF(IPLT.GE.0)CALL DPYOUT(1)
	END
	
	SUBROUTINE SAVE(M)
	DIMENSION M(1)
	J=7
	L=8
	DO 12 K=1,M(1),8
	IF(K+J.LT.M(1))GO TO 12
	J=M(1)-K
	L=J+1
12	WRITE(1,11)L,(M(NM),NM=K,K+J)
	RETURN
11	FORMAT(' 9999',I3,8I10)
	END